home *** CD-ROM | disk | FTP | other *** search
/ CD Ware Multimedia 1995 May / cd Ware (Juegos) Epimundo.iso / DOS / PRGMMING / QUIKDB.ZIP / GETFIELD.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-11-15  |  15.6 KB  |  544 lines
  1. Unit GetField;
  2.  
  3. Interface
  4.  
  5. uses Crt,screenio;
  6.  
  7. procedure Field_Str(Xpos, Ypos, Len : Byte;
  8.                     Prompt      : String;
  9.                     Var UserStr : String;
  10.                     Picture     : string);
  11.  
  12. procedure SetUp_Field(PromptColor,ActiveFColor,InactiveFColor,ShadowC : Byte;
  13.                       ClearChar : Char;
  14.                       EscKey,Clean,Confirm,Bell,UpDn,Wndw : Boolean);
  15.  
  16. procedure GetString(Ypos,Xpos,Attr,Len : Byte;
  17.                     Var Str255 : String;
  18.                     Picture : string;
  19.                     Var Keyval : Integer);
  20.  
  21. procedure GetStr(Ypos,Xpos : Byte;
  22.                  Var Str255 : String;
  23.                  Picture : string);
  24.  
  25. procedure Disp_Fields;
  26.  
  27. procedure Do_Fields(Var KeyVal : Integer);
  28.  
  29. function  Get_Key : Integer;
  30.  
  31. procedure NumStr(Var Fstr : string;
  32.                  Len,Dec : byte);
  33.  
  34. procedure Release_Fields;
  35.  
  36. var
  37.   Field_Id : byte;
  38.   ESC_KEY  : BOOLEAN;
  39.  
  40. implementation
  41.  
  42. const
  43.   _A = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
  44.   _L = 'TF';
  45.   _N = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890';
  46.   _Y = 'NY';
  47.   _9 = '1234567890-.';
  48.   _D = '1234567890- ';
  49.   _P = '@ALNXY9#!$*';
  50.  
  51. Type
  52.   Field_IO = Record
  53.                Xpos,Ypos,Len,Exit,Opts : Byte;
  54.                UserStr : ^String;
  55.                Picture : String;
  56.                Decimal : integer;
  57.                CharType: Char;
  58.                Prompt  : String;
  59.              end;
  60. Var
  61.   Field_Array     : Array[1..256] of ^Field_IO;
  62.   Max_Field       : Byte;
  63.   Active_Fcolor   : Byte;
  64.   _Shadow         : byte;
  65.   Inactive_Fcolor : Byte;
  66.   Prompt_Color    : byte;
  67.   Up_X,Up_Y,
  68.   Lo_X,Lo_Y       : byte;
  69.   Clear_Char      : Char;
  70.   UpDn_Enable     : Boolean;
  71.   Esc_Exit,_Bell,
  72.   _Confirm,_INS,
  73.   Clean_Str       : Boolean;
  74.   Disp_Win        : Boolean;
  75.   Decimal         : byte;
  76.   CharType        : Char;
  77.   _LEGAL          : char;
  78.  
  79. procedure TrimStr(VAR InputStr : string;
  80.                       CChar    : Char);
  81.   var
  82.     count  : byte;
  83.   begin
  84.     count := Length(InputStr);
  85.     while (InputStr[count] = CChar) and (count > 0) do
  86.       begin
  87.         Delete(InputStr,count,1);
  88.         dec(count);
  89.       end;
  90.     while (InputStr[1] = CChar) and (Length(InputStr) > 0) do
  91.       Delete(InputStr,1,1);
  92.   end;
  93.  
  94. procedure NumStr(Var Fstr : string;
  95.                  Len,Dec : byte);
  96.   var
  97.     RealInt : Real;
  98.     code : integer;
  99.   begin
  100.     while Pos(Clear_Char,Fstr) > 0 do
  101.       delete(Fstr,Pos(Clear_Char,Fstr),1);
  102.     Val(Fstr,RealInt,code);
  103.     Str(RealInt:Len:Dec,Fstr);
  104.   end;
  105.  
  106. function NumToStr(num : integer;len : byte) : string;
  107.   var
  108.     str1 : string;
  109.     count : byte;
  110.   begin
  111.     Str(num:len,str1);
  112.     for count := 1 to length(str1) do
  113.       if str1[count] = ' ' then str1[count] := '0';
  114.     NumToStr := Str1;
  115.   end;
  116.  
  117. function ValidDate(var datestr : string) : boolean;
  118.   var
  119.     month,day,year : byte;
  120.     code           : integer;
  121.     tempstr        : string;
  122.   begin
  123.     tempstr := copy(datestr,1,2);
  124.     TrimStr(TempStr,' ');
  125.     Val(TempStr,month,code);
  126.     tempstr := copy(datestr,4,2);
  127.     TrimStr(TempStr,' ');
  128.     Val(TempStr,day,code);
  129.     tempstr := copy(datestr,7,2);
  130.     TrimStr(TempStr,' ');
  131.     Val(TempStr,year,code);
  132.     if (month > 0) and (month < 13) and (day > 0) and (day < 32) then
  133.         begin
  134.           datestr := NumToStr(month,2)+datestr[3]+NumToStr(day,2)+datestr[6]+NumToStr(year,2);
  135.           ValidDate := True
  136.         end else ValidDate := False;
  137.   end;
  138.  
  139. procedure Field_Str;
  140.   var
  141.     count : byte;
  142.     code  : integer;
  143.     fchar : char;
  144.   begin
  145.     inc(Max_Field,1);
  146.     New(Field_Array[Max_Field]);
  147.     Field_Array[Max_Field]^.Decimal := 0;
  148.     Field_Array[Max_Field]^.CharType:= 'C';
  149.     fchar := 'X';
  150.     if length(picture) > 1 then
  151.       if picture[1] = '@' then
  152.         begin
  153.           fchar   := picture[2];
  154.           if fchar = '9' then
  155.             begin
  156.               if (length(picture) > 3) and (picture[3] = ':') then
  157.                 Val(picture[4],Field_Array[Max_Field]^.Decimal,code);
  158.               Field_Array[Max_Field]^.CharType:= 'N';
  159.             end;
  160.           if fchar = 'D' then
  161.             begin
  162.               picture := '99/99/99';
  163.               len := 8;
  164.               Field_Array[Max_Field]^.CharType:= 'D';
  165.             end else picture := fchar;
  166.         end;
  167.     if Length(UserStr) > Len then Delete(UserStr,Len,Length(UserStr)-Len);
  168.     for count := 1 to (Len-Length(UserStr)) do
  169.       UserStr := UserStr + Clear_Char;
  170.     for count := Length(Picture)to Len do
  171.       Picture := Picture + fchar;
  172.     for count := 1 to Length(Picture) do
  173.       begin
  174.         if pos(picture[count],_P) = 0 then UserStr[count] := Picture[count];
  175.         if Picture[count] = '!' then UserStr[count] := UpCase(UserStr[count]);
  176.       end;
  177.     if Field_Array[Max_Field]^.Decimal > 0 then
  178.       begin
  179.         delete(Picture,Len-Field_Array[Max_Field]^.Decimal,1);
  180.         Insert('.',Picture,Len-Field_Array[Max_Field]^.Decimal);
  181.         NumStr(UserStr,Len,Field_Array[Max_Field]^.Decimal);
  182.       end;
  183.     Field_Array[Max_Field]^.Prompt  := Prompt;
  184.     Field_Array[Max_Field]^.Xpos    := Xpos+Length(Prompt);
  185.     Field_Array[Max_Field]^.Ypos    := Ypos;
  186.     Field_Array[Max_Field]^.Len     := Len;
  187.     Field_Array[Max_Field]^.UserStr := @UserStr;
  188.     Field_Array[Max_Field]^.Picture := Picture;
  189.     if Up_X > Xpos then Up_X := Xpos;
  190.     if Up_Y > Ypos then Up_Y := Ypos;
  191.     if Lo_X < (Xpos+Length(prompt)+Len-1) then Lo_X := (Xpos+Length(prompt)+Len-1);
  192.     if Lo_Y < Ypos then Lo_Y := Ypos;
  193.   end;
  194.  
  195. procedure SetUp_Field;
  196.   begin
  197.     Prompt_Color    := PromptColor;
  198.     Active_FColor   := ActiveFColor;
  199.     Inactive_Fcolor := InactiveFColor;
  200.     _Shadow         := ShadowC;
  201.     Clear_Char      := ClearChar;
  202.     Disp_Win        := Wndw;
  203.     Esc_Exit        := EscKey;
  204.     if Max_Field = 0 then
  205.       begin
  206.         Up_X            := 80;
  207.         Up_Y            := 25;
  208.         Lo_X            := 0;
  209.         Lo_Y            := 0;
  210.         Field_Id        := 1;
  211.       end;
  212.     Clean_Str       := Clean;
  213.     _Confirm        := Confirm;
  214.     _Bell           := Bell;
  215.     UpDn_Enable     := UpDn;
  216.     ESC_KEY         := FALSE;
  217.   end;
  218.  
  219. procedure Release_Fields;
  220.   Var
  221.     Field_Num,count : Byte;
  222.   begin
  223.     textattr := Inactive_Fcolor;
  224.     for Field_Num := 1 to Max_Field do
  225.       with Field_Array[Field_Num]^ do
  226.         begin
  227.           gotoxy(Xpos,Ypos);
  228.           Write(UserStr^);
  229.           if Clean_Str then TrimStr(UserStr^,Clear_Char);
  230.         end;
  231.     For Field_Num := 1 to Max_Field do
  232.       Dispose(Field_Array[Field_Num]);
  233.     Max_Field := 0;
  234.   end;
  235.  
  236. function Get_Key : Integer;
  237.   Var CH : Char;
  238.       Int : Integer;
  239.   begin
  240.     CH := ReadKey;
  241.     If CH = #0 then
  242.       begin
  243.         CH := ReadKey;
  244.         int := Ord(CH);
  245.         inc(int,256);
  246.       end else Int := Ord(CH);
  247.     Get_Key := Int;
  248.   end;
  249.  
  250. procedure GetString;
  251.  
  252. Var
  253.   Position,
  254.   count    : Byte;
  255.   Exit     : Boolean;
  256.  
  257.   function validpos : boolean;
  258.     begin
  259.       if pos(picture[position],_P) > 0 then validpos := True
  260.         else validpos := false;
  261.     end;
  262.  
  263.   procedure WriteString;
  264.     Var X : Byte;
  265.     begin
  266.       GotoXY(Xpos,Ypos);
  267.       Write(Str255);
  268.     end;
  269.  
  270.   procedure BackSpaceChar;
  271.     var
  272.       temppos : byte;
  273.     Begin
  274.       temppos := Position;
  275.       while (Pos(picture[temppos-1],_P) = 0) and (temppos > 0) do
  276.         dec(temppos);
  277.       if TempPos > 1 then
  278.         begin
  279.           delete(Str255,temppos-1,1);
  280.           position := TempPos;
  281.           dec(Position);
  282.           temppos := Position;
  283.           while (Pos(picture[temppos+1],_P) > 0) and (temppos < Len+ 1) do
  284.             inc(temppos);
  285.           insert(Clear_Char,Str255,temppos);
  286.           WriteString;
  287.         end;
  288.     end;
  289.  
  290.   procedure DeleteChar;
  291.     Begin
  292.       inc(Position);
  293.       BackSpaceChar;
  294.     end;
  295.  
  296.   function FixNum : boolean;
  297.     begin
  298.       FixNum := True;
  299.       if Char(Keyval) = '.' then
  300.         if decimal > 0 then
  301.           begin
  302.             if Position < Pos('.',Str255) then
  303.               while Position < Pos('.',Str255) do
  304.                 begin
  305.                   Str255[position] := ' ';
  306.                   inc(Position);
  307.                 end else Position := Pos('.',Str255);
  308.             inc(Position);
  309.             NumStr(Str255,Len,Decimal);
  310.             WriteString;
  311.             GotoXY(Xpos+Position-1,Ypos);
  312.             FixNum := False;
  313.           end;
  314.     end;
  315.  
  316.   procedure WriteChar;
  317.     Var
  318.       DoWrite : Boolean;
  319.       temppos : Byte;
  320.     Begin
  321.       If Position <= Len then
  322.         begin
  323.           DoWrite := True;
  324.           case Picture[Position] of
  325.             '!' : Char(KeyVal) := UpCase(Chr(KeyVal));
  326.             'X' : ;
  327.             'A' : If Pos(upcase(Char(KeyVal)),_A) = 0 then
  328.                     begin
  329.                       DoWrite := False;
  330.                       InValidInput('Letters Only');;
  331.                       write(Chr(07));
  332.                     end;
  333.             'N' : If Pos(Char(KeyVal),_N) = 0 then
  334.                     begin
  335.                       DoWrite := False;
  336.                       InValidInput('Letters and Numbers Only');
  337.                       write(Chr(07));
  338.                     end;
  339.             'L' : If Pos(upcase(Char(KeyVal)),_L) = 0 then
  340.                     begin
  341.                       DoWrite := False;
  342.                       InValidInput('T or F Only Allowed');;
  343.                       write(Chr(07));
  344.                     end else Char(KeyVal) := UpCase(Chr(KeyVal));
  345.             'Y' : If Pos(upcase(Char(KeyVal)),_Y) = 0 then
  346.                     begin
  347.                       DoWrite := False;
  348.                       InValidInput('Y or N Only Allowed');;
  349.                       write(Chr(07));
  350.                     end else Char(KeyVal) := UpCase(Chr(KeyVal));
  351.             '#' : If Pos(Char(KeyVal),_D) = 0 then
  352.                     begin
  353.                       DoWrite := False;
  354.                       InValidInput('Numbers Only');;
  355.                       write(Chr(07));
  356.                     end;
  357.             '9' : If Pos(Char(KeyVal),_9) = 0 then
  358.                     begin
  359.                       DoWrite := False;
  360.                       InValidInput('Numeric Values Only');;
  361.                       write(Chr(07));
  362.                     end else DoWrite := FixNum;
  363.             else DoWrite := False;
  364.           end;
  365.           If DoWrite then
  366.           begin
  367.             If _INS then begin
  368.               Insert(Char(Keyval),Str255,Position);
  369.               temppos := Position;
  370.               while (Pos(picture[temppos],_P) > 0) and (temppos < Len+1) do
  371.                 inc(temppos);
  372.               delete(Str255,TempPos,1);
  373.             end else Str255[Position] := Char(KeyVal);
  374.             WriteString;
  375.             repeat
  376.               Inc(Position);
  377.             until validpos or (position > len);
  378.             GotoXY(Xpos+Position-1,Ypos);
  379.           end;
  380.         end;
  381.         if (Not _Confirm) and (Position > len) then
  382.           begin
  383.             Exit := true;
  384.             if _BELL then soundbell;
  385.           end;
  386.  
  387.     End;
  388.  
  389.   procedure EditString;
  390.     Begin
  391.       KeyVal := Get_Key;
  392.       If ErrPrompt then ClearInvalid;
  393.       Case KeyVal of
  394. {Back}    8 : If Position > 1 then BackSpaceChar
  395.                 else if Not _Confirm then begin
  396.                                             Exit := True;
  397.                                             KeyVal := 331;
  398.                                           end;
  399. {Esc}    27 : Exit := True;
  400. {Return} 13 : Exit := True;
  401. {Home}  327 : Position := 1;
  402. {Up}    328 : Exit := True;
  403. {PgUp}  329 : Exit := True;
  404. {Left}  331 : If Position > 1 then
  405.                 repeat
  406.                   dec(Position);
  407.                 until validpos or (position = 1)
  408.               else if Not _Confirm then Exit := True;
  409. {Right} 333 : If Position < Len then
  410.                 repeat
  411.                   inc(Position);
  412.                 until validpos or (position > len)
  413.               else if Not _Confirm then Exit := True;
  414. {End}   335 : begin
  415.                 position := Length(Str255)+1;
  416.                 while (position > 0) and (Str255[Position-1] = Clear_Char) do
  417.                   dec(Position);
  418.               end;
  419. {Down}  336 : Exit := True;
  420. {PgDn}  337 : Exit := True;
  421. {Ins}   338 : If _INS then _INS := False else _INS := True;
  422. {Del}   339 : DeleteChar;
  423.       end;
  424.       If (KeyVal < 256) and (Keyval > 27) then
  425.         WriteChar
  426.       else begin
  427.              while (Pos(picture[position],_P) = 0) and (position < Len+1) do
  428.                inc(Position);
  429.              GotoXY(Xpos+Position-1,Ypos);
  430.            end;
  431.     end;
  432.  
  433. begin
  434.   Exit      := false;
  435.   _INS      := False;
  436.   TextAttr  := Attr;
  437.   Position  := 1;
  438.   _LEGAL    := 'U';
  439.   WriteString;
  440.   while Length(Picture) < Len do
  441.     picture := picture + 'X';
  442.   while (Pos(picture[position],_P) = 0) and (position < Len+1) do
  443.     inc(Position);
  444.   if (Not _Confirm) and (Keyval = 331) then Position := Len;
  445.   GotoXY(Xpos+Position-1,Ypos);
  446.   repeat
  447.     EditString;
  448.     if Exit then
  449.       if chartype = 'D' then
  450.         if (KeyVal <> 27) and (ValidDate(Str255) = FALSE) and (str255 <> '  /  /  ') then
  451.           begin
  452.             Exit := False;
  453.             InValidInput('Invalid Date');
  454.             SoundBell;
  455.           end;
  456.     If Not Esc_Exit then
  457.       If KeyVal = 27 then
  458.         Exit := False;
  459.   until Exit;
  460.   if chartype = 'N' then
  461.     NumStr(Str255,Len,Decimal);
  462.   GotoXY(Xpos,Ypos);
  463.   write(Str255);
  464.   if KeyVal = 27 then ESC_KEY := TRUE
  465.     else ESC_KEY := FALSE;
  466. end;
  467.  
  468. procedure GetStr(Ypos,Xpos : Byte;
  469.                  Var Str255 : String;
  470.                  Picture : string);
  471.   var
  472.     ReturnVal : Integer;
  473.     oldattr : byte;
  474.   begin
  475.     Oldattr := textattr;
  476.     GetString(Ypos,Xpos,Active_Fcolor,Length(Str255),Str255,Picture,ReturnVal);
  477.     textattr := OldAttr;
  478.     if ReturnVal = 27 then ESC_KEY := TRUE
  479.       else ESC_KEY := FALSE;
  480.   end;
  481.  
  482. procedure Disp_Windw;
  483.   begin
  484.     DrawBox('',Single,Up_X-2,Up_Y-1,Lo_X+2,Lo_Y+1,_Shadow,Prompt_Color,Prompt_Color);
  485.   end;
  486.  
  487. procedure Disp_Fields;
  488.   var
  489.     Field_Num : byte;
  490.     Old_Attr : byte;
  491.   begin
  492.     old_attr := textattr;
  493.     if Disp_Win then Disp_Windw;
  494.     for Field_Num := 1 to Max_Field do
  495.       with Field_Array[Field_Num]^ do
  496.         begin
  497.           gotoxy(Xpos-Length(Prompt),Ypos);
  498.           textattr := Prompt_color;
  499.           write(prompt);
  500.           textattr := Active_Fcolor;
  501.           write(UserStr^);
  502.         end;
  503.     textattr := Old_Attr;
  504.   end;
  505.  
  506. procedure Do_Fields;
  507.   Var
  508.     Exit : Boolean;
  509.     count : byte;
  510.     old_Attr : Byte;
  511.   begin
  512.     if Max_Field > 0 then
  513.     begin
  514.     old_attr := textattr;
  515.     Disp_Fields;
  516.     Repeat
  517.       Decimal  := Field_Array[Field_Id]^.Decimal;
  518.       CharType := Field_Array[Field_Id]^.CharType;
  519.       With Field_Array[Field_Id]^ do
  520.         GetString(Ypos,Xpos,Active_Fcolor,Len,UserStr^,Picture,KeyVal);
  521.       If (Field_Id = Max_Field) and (KeyVal = 13) or
  522.         (KeyVal = 337) or (KeyVal = 27) then
  523.           Exit := True else Exit := False;
  524.       if (UpDn_Enable = FALSE) and ((KeyVal = 328) or (KeyVal = 336)) then Exit := True
  525.         else Case KeyVal of
  526.                13,336,333 : If Field_Id = Max_Field then
  527.                               Field_Id := 1 else inc(Field_Id);
  528.                328,331    : If Field_Id = 1 then
  529.                               Field_Id := Max_Field
  530.                             else dec(Field_Id,1);
  531.              else If Field_Id = Max_Field then
  532.                      Field_Id := 1 else inc(Field_Id);
  533.              end;
  534.     Until Exit;
  535.     release_fields;
  536.     Textattr := Old_Attr;
  537.     end;
  538.   end;
  539.  
  540. begin
  541.   Max_Field := 0;
  542.   SetUp_Field($07,$70,$07,$00,' ',True,false,true,true,true,true);
  543. end.
  544.